home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / 4dostool / tfc22c.zip / TCV.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-03  |  22KB  |  736 lines
  1. {$X+}
  2. {
  3.     TCV Tobi's Catalogue Vison  Version 2.2  11-3-93, 9:35 AM
  4.     
  5.        This BP source is released into the Public Domain
  6.        Feel free to make changes to this program but
  7.        don't remove my name and address ...
  8.  
  9.        Let me know if you made any enhancements or if
  10.        you find errors ...
  11.  
  12.        Thanks for Additions and Corrections to:
  13.  
  14.                . David Frey (no e-Mail)
  15.                . Thomas Ludwig (ludwig@informatik.tu-muenchen.de)
  16.                . Maettu Studer (no e-Mail)
  17.                . Robert Juhasz (robertj@uni-paderborn.de)
  18.  
  19.        Written by
  20.  
  21.                  Tobi Oetiker (oetiker@stud.ee.ethz.ch or 2:301/516.2@fido)
  22.                  Gallusstrasse 25 / CH-4600 Olten / FAX +41 62 32 61
  23.  
  24.       Revisions:
  25.          
  26.             V2.2 --- . Highlighted Current Search String.
  27. }
  28.  
  29. Program Tobis_Catalog_Vision;
  30. {$M 16384,16384,655360}
  31. Uses App, Objects, Menus, Drivers, Views, Dialogs, MsgBox, Memory, DOS, 
  32.      HistList, fix;
  33.  
  34. Const VERSION = '2.2';
  35. Type
  36.   TTCV = Object (TApplication)
  37.            DWPresent: Boolean;
  38.            Constructor Init;
  39.            Procedure InitStatusline; Virtual;
  40.            Procedure InitMenuBar; Virtual;
  41.            Procedure InitDesktop; Virtual;
  42.            Procedure DataWindow;
  43.          End;
  44.   
  45.   PDataWin = ^TDataWin;
  46.   TDataWin = Object (TDialog)
  47.              End;
  48.   
  49.   PTCVStatLine = ^TTCVStatLine;
  50.   TTCVStatLine = Object (TStatusLine)
  51.                    Function Hint (AHelpCtx: Word): String; Virtual;
  52.                    Procedure Draw; Virtual;
  53.                    
  54.                  End;
  55.   
  56.   PDiskCol = ^TDiskCol;
  57.   TDiskCol = Object (TStringcollection)
  58.                LineBuf: String;
  59.                LineBufNr: Integer;
  60.                EntryBuf: Array [1..6] Of String [80];
  61.                EntryBufNr: Integer;
  62.                Constructor Init (ALimit, ADelta: Integer);
  63.  
  64.                Function GetEntry (Zeile: Integer; Nummer: Byte): String;
  65.                Function FindNext (Start: Integer; Key: String): Integer;
  66.                Function FindPrev (Start: Integer; Key: String): Integer;
  67.                Function DirLine (Welche: Integer): String;
  68.              End;
  69.   
  70.   PDirBox = ^TDirBox;
  71.   TDirBox = Object (TListBox)
  72.               Search: String;
  73.               Constructor Init (Var Bounds: TRect; ANumCols: Word;
  74.               AScrollBar: PScrollBar);
  75.               Destructor Done; Virtual;
  76.               Procedure Draw; Virtual;
  77.               Procedure HandleEvent (Var Event: TEvent); Virtual;
  78.             End;
  79.   PHButton = ^THButton;
  80.   THButton = Object (TButton)
  81.                Constructor Init (Var Bounds: TRect; ATitle: TTitleStr;
  82.                ACommand: Word; AFlags: Word; Hnr: Word);
  83.              End;
  84. Const  hcBrowseMode = 1000;
  85.   hcSearchMode = 1003;
  86.   hcSearching = 1004;
  87.   hcReading = 1005;
  88.   hcAbout = 1006;
  89.   hcInfo = 1007;
  90.   hcExit = 1008;
  91.   cmInfo = 100;
  92.   cmAbout = 101;
  93.   
  94. Function NoCasePos (a, b: String): Byte;
  95.   Var i: Integer;
  96.   Begin
  97.     If Length (a) > 0 Then
  98.     Begin
  99.       For i := 1 To Length (a) Do a [i] := UpCase (a [i] );
  100.       For i := 1 To Length (b) Do b [i] := UpCase (b [i] );
  101.       NoCasePos := Pos (a, b);
  102.     End
  103.     Else
  104.       NoCasePos := 0;
  105.   End;
  106.  
  107. Function LineCheck (S: String): Boolean;
  108. Var i, l: Byte;
  109. Begin
  110.   i := 2;
  111.   l := Length (s);
  112.   If s [1] = '"' Then
  113.   Begin
  114.     While (i < l) And Not (s [i] = '"') Do Inc (i);
  115.     If i < l Then
  116.     Begin
  117.       i := i + 3;
  118.       While (i < l) And Not (s [i] = '"') Do Inc (i);
  119.       If i < l Then
  120.       Begin
  121.         i := i + 3;
  122.         While (i < l) And Not (s [i] = '"') Do Inc (i);
  123.         If i < l Then
  124.         Begin
  125.           i := i + 3;
  126.           While (s [i] >= '0') And (s [i] <= '9') And (i < l) Do Inc (i);
  127.           If s [i] = ',' Then
  128.           Begin
  129.             i := i + 2;
  130.             While (i < l) And Not (s [i] = '"') Do Inc (i);
  131.             If i < l Then
  132.             Begin
  133.               i := i + 3;
  134.               While (i < l) And Not (s [i] = '"') Do Inc (i);
  135.               If s [i] = '"' Then
  136.               Begin
  137.                 LineCheck := True;
  138.                 Exit;
  139.               End;
  140.             End;
  141.           End;
  142.         End;
  143.       End;
  144.     End;
  145.   End;
  146.   LineCheck := False;
  147. End;
  148.  
  149.  
  150. Function ToString (STRP: PString): String;
  151. Begin
  152.   If STRP <> Nil Then
  153.     ToString := STRP^
  154.   Else
  155.     ToString := '"#ERROR#","x","x",2,"x","x"';
  156. End;
  157.  
  158. Constructor THButton. Init (Var Bounds: TRect; ATitle: TTitleStr;
  159.              ACommand: Word; AFlags: Word; Hnr: Word);
  160. Begin
  161.   TButton. Init (Bounds, ATitle, ACommand, AFlags);
  162.   HelpCtx := Hnr;
  163. End;
  164.  
  165. Function TDiskCol. GetEntry (Zeile: Integer; Nummer: Byte): String;
  166. Var zeiger, i: Byte;
  167.   s: String;
  168. Begin
  169.   If Zeile <> EntryBufNr Then
  170.   Begin
  171.     s := ToString (At (Zeile) );
  172.     EntryBufNr := Zeile;
  173.     i := 2;
  174.     Zeiger := 2;
  175.     While s [Zeiger] <> '"' Do Inc (Zeiger);
  176.     EntryBuf [1] := Copy (s, i, Zeiger - i);
  177.     
  178.     i := Zeiger + 3;
  179.     Zeiger := i;
  180.     While s [Zeiger] <> '"' Do Inc (Zeiger);
  181.     EntryBuf [2] := Copy (s, i, Zeiger - i);
  182.     i := Zeiger + 3;
  183.     Zeiger := i;
  184.     While s [Zeiger] <> '"' Do Inc (Zeiger);
  185.     EntryBuf [3] := Copy (s, i, Zeiger - i);
  186.     i := Zeiger + 2;
  187.     Zeiger := i;
  188.     While s [Zeiger] <> ',' Do Inc (Zeiger);
  189.     EntryBuf [4] := Copy (s, i, Zeiger - i);
  190.     i := Zeiger + 2;
  191.     Zeiger := i;
  192.     While s [Zeiger] <> '"' Do Inc (Zeiger);
  193.     EntryBuf [5] := Copy (s, i, Zeiger - i);
  194.     i := Zeiger + 3;
  195.     Zeiger := i;
  196.     While s [Zeiger] <> '"' Do Inc (Zeiger);
  197.     EntryBuf [6] := Copy (s, i, Zeiger - i);
  198.   End;
  199.   GetEntry := EntryBuf [Nummer];
  200. End;
  201.  
  202. Function TDiskCol. DirLine (Welche: Integer): String;
  203. Var LS, DI, Fi, Co: String;
  204. Const Space = '                            ';
  205. Begin;
  206.   If Welche = LineBufNr Then
  207.   Begin
  208.     DirLine := LineBuf;
  209.     Exit;
  210.   End;
  211.   DI := ' ' + Copy (GetEntry (Welche, 1) + Space, 1, 14);
  212.   Fi := Copy (GetEntry (Welche, 3) + Space, 1, 15);
  213.   Co := GetEntry (Welche, 5);
  214.   LineBuf := DI + Fi + Co;
  215.   LineBufNr := Welche;
  216.   DirLine := LineBuf;
  217. End;
  218.  
  219. Constructor TDiskCol. Init (ALimit, ADelta: Integer);
  220. Begin
  221.   TStringCollection. Init (ALimit, ADelta);
  222.   LineBufNr := - 1;
  223.   EntryBufNr := - 1;
  224. End;
  225.  
  226. Function TDiskCol. FindNext (Start: Integer; Key: String): Integer;
  227. Var i: Integer;
  228.   p: Byte;
  229. Begin
  230.   If (Start >= 0) And (Start < Count) And (Key <> '') Then
  231.   Begin
  232.     i := Start - 1;
  233.     p := 0;
  234.     While (i < Count - 1) And (p = 0) Do
  235.     Begin
  236.       Inc (i);
  237.       p := NoCasePos (Key, DirLine (i) );
  238.     End;
  239.     If p = 0 Then
  240.       FindNext := Start
  241.     Else
  242.       FindNext := i;
  243.   End
  244.   Else
  245.     FindNext := 0;
  246. End;
  247.  
  248. Function TDiskCol. FindPrev (Start: Integer; Key: String): Integer;
  249. Var i, p: Integer;
  250. Begin
  251.   If (Start >= 1) And (key <> '') Then
  252.   Begin
  253.     i := Start;
  254.     p := 0;
  255.     While (i >= 1) And (p = 0) Do
  256.     Begin
  257.       Dec (i);
  258.       p := NoCasePos (Key, DirLine (i) );
  259.     End;
  260.     FindPrev := i;
  261.   End
  262.   Else
  263.     FindPrev := Start;
  264. End;
  265.  
  266.  
  267. Destructor TDirBox. Done;
  268. Begin
  269.   NewList (Nil);
  270.   TListBox. Done;
  271. End;
  272.  
  273. Constructor TDirBox. Init (Var Bounds: TRect; ANumCols: Word;
  274.                              AScrollBar: PScrollBar);
  275.  
  276.  
  277. Var DataCol: PDiskCol;
  278.   LineCount: LongInt;
  279.   err: Boolean;
  280.   
  281. Procedure ReadFile;
  282.    Var
  283.      F: Text;
  284.      S: String;
  285.      propah: PathStr;
  286.      
  287.    Function FiletoRead: PathStr;
  288.      Var
  289.        EXEName: PathStr;
  290.        Dir: DirStr;
  291.        Name: NameStr;
  292.        Ext: ExtStr;
  293.        gefunden: PathStr;
  294.      Begin
  295.        If Lo (DosVersion) >= 3 Then EXEName := ParamStr (0)
  296.        Else EXEName := FSearch ('TCV.EXE', GetEnv ('PATH') );
  297.        FSplit (EXEName, Dir, Name, Ext);
  298.        If Dir [Length (Dir) ] = '\' Then Dec (Dir [0] );
  299.        FiletoRead := FSearch ('PROGS.TFC', Dir);
  300.        blockCursor;
  301.      End;
  302.  
  303.    Begin
  304.      err := False;
  305.      LineCount := 0;
  306.      DataCol := New (PDiskCol, Init (1000, 10) );
  307.      ProPah := FiletoRead;
  308.      {$I-}
  309.      Assign (f, ProPah);
  310.